home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / dynami_1 / balloonm.bas < prev    next >
BASIC Source File  |  1999-08-31  |  12KB  |  343 lines
  1. Attribute VB_Name = "BalloonMod"
  2. '------------------------------------------------
  3. ' ________  Copyright EAguirre (c)1999
  4. '(        ) eaguirre@comtrade.com.mx
  5. '(  ______) Be carefull with subclassing a window
  6. ' \/
  7. ' BalloonToolTip
  8. '-------------------------------------------------
  9. Option Explicit
  10.  
  11. Const GWL_WNDPROC = -4
  12. Const HeightCaption = 325 'Twips
  13.  
  14. Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  15. Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  16.  
  17. Dim oldAddress As Long              'Old address of the WndProc
  18. Dim BalloonForm As Form             'Balloon Form Instance
  19. Dim HookedForm As Form              'Hooked Form (subclassing)
  20. Dim BalloonCtrl As Control          'Control under the mouse
  21. Dim TipCtrl As Control              'Tip control
  22. Dim BalloonBox As RECT              'Balloon Box coordinates
  23.  
  24. Function HiWord(dw As Long) As Long
  25.     If dw And &H80000000 Then
  26.         HiWord = (dw \ 65536) - 1
  27.     Else
  28.         HiWord = dw \ 65536
  29.     End If
  30. End Function
  31.  
  32. Function LoWord(dw As Long) As Long
  33.     If dw And &H8000& Then
  34.         LoWord = &H8000 Or (dw And &H7FFF&)
  35.     Else
  36.         LoWord = dw And &HFFFF&
  37.     End If
  38. End Function
  39.  
  40. Public Sub InitProc(ByRef frmParent As Form)
  41.     If frmParent Is Nothing Then Exit Sub
  42.     'Hook the window
  43.     Set HookedForm = frmParent
  44.     'Assign the TipControl
  45.     For Each TipCtrl In HookedForm
  46.       If TypeOf TipCtrl Is BalloonTip Then Exit For
  47.     Next TipCtrl
  48.    'Creating a balloon window
  49.     Set BalloonForm = New frmBalloon
  50.    'Set the new WndProc to the parent form
  51.     oldAddress = SetWindowLong(HookedForm.hwnd, GWL_WNDPROC, AddressOf WndProc)
  52. End Sub
  53.  
  54. Sub TerminateProc()
  55.   Dim TProc As Long
  56.   If HookedForm Is Nothing Then Exit Sub
  57.   'Restore the old window procedure
  58.   TProc = SetWindowLong(HookedForm.hwnd, GWL_WNDPROC, oldAddress)
  59.   'Restore memory
  60.   Unload BalloonForm
  61.   Set BalloonForm = Nothing
  62.   Set HookedForm = Nothing
  63.   Set TipCtrl = Nothing
  64. End Sub
  65.  
  66. Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  67.  
  68. On Error Resume Next
  69. 'Calling the original Window Procedure
  70. WndProc = CallWindowProc(oldAddress, hwnd, uMsg, wParam, lParam)
  71. 'Subclassing the original form
  72. Select Case uMsg
  73.     Case WM_SETCURSOR
  74.         Dim wndhWnd As Long
  75.         Dim mouseMsg As Long
  76.         Dim ctrl As Control
  77.               
  78.         ' wParam holds the handle of the window under the cursor
  79.         wndhWnd = wParam
  80.         ' High word of lParam = Mouse Message
  81.         mouseMsg = HiWord(lParam)
  82.            
  83.         If mouseMsg = WM_MOUSEMOVE Then
  84.           If BalloonCtrl.hwnd <> wndhWnd Then
  85.              HideTip
  86.              'Search the control under cursor
  87.              For Each ctrl In HookedForm.Controls
  88.                If ctrl.hwnd <> wndhWnd Then
  89.                'hWnd property not supported or not found yet
  90.                Else
  91.                  Set BalloonCtrl = ctrl
  92.                  With ctrl
  93.                    TipCtrl.Text = .ToolTipText
  94.                    .ToolTipText = ""
  95.                    'Turn on the timer
  96.                    BalloonForm.Controls(0).Enabled = True
  97.                  End With
  98.                  Exit For
  99.                End If
  100.              Next
  101.            End If
  102.         End If
  103.         'Hide Tip in case of mouse click's
  104.         If (mouseMsg = WM_LBUTTONDOWN) Or (mouseMsg = WM_MBUTTONDOWN) _
  105.            Or (mouseMsg = WM_RBUTTONDOWN) Then HideTip
  106.         
  107.     Case WM_HSCROLL, WM_KEYDOWN, WM_KEYUP, WM_VSCROLL
  108.       HideTip
  109. End Select
  110. End Function
  111.  
  112. Private Sub HideTip()
  113. Dim mCount As Integer
  114. If Not (BalloonCtrl Is Nothing) Then
  115.      With BalloonForm
  116.         'Turn off the timer
  117.         .Controls(0).Enabled = False
  118.         'Hide Balloon Form
  119.         .Hide
  120.      End With
  121.     'Restore Values of the Control
  122.      BalloonCtrl.ToolTipText = TipCtrl.Text
  123.      TipCtrl.Text = ""
  124.      Set BalloonCtrl = Nothing
  125.     'Show mouse pointer
  126.      mCount = ShowCursor(True)
  127.      Do While mCount < 0
  128.        mCount = ShowCursor(True)
  129.      Loop
  130. End If
  131. End Sub
  132.  
  133. Private Sub ChangeStyle()
  134. Dim Reg(2) As Long
  135. Dim P(3) As POINTAPI
  136. Dim Box As RECT
  137. Dim w As Single, h As Single
  138. 'Copy values to variables for optimization
  139. w = BalloonForm.ScaleWidth: h = BalloonForm.ScaleHeight
  140. 'Establish the form of the balloon depending the Orientation
  141. 'Property.
  142. Select Case TipCtrl.Orientation
  143.     Case North, South
  144.        P(0).x = (w / 2) - (w * 0.15): P(0).y = h / 2
  145.        P(1).x = (w / 2) + (w * 0.15): P(1).y = h / 2
  146.        P(2).x = w / 2
  147.        Box.Left = 0: Box.Right = w
  148.        If TipCtrl.Orientation = North Then
  149.          Box.Top = 0:   Box.Bottom = h - (h * 0.1)
  150.          P(2).y = h
  151.        Else
  152.          Box.Top = h * 0.1: Box.Bottom = h
  153.          P(2).y = 0
  154.        End If
  155.     Case NE, Sw
  156.        P(0).x = (w / 2) - (w * 0.15): P(0).y = (h / 2) - (h * 0.15)
  157.        P(1).x = (w / 2) + (w * 0.15): P(1).y = (h / 2) + (h * 0.15)
  158.        Box.Left = 0: Box.Right = w
  159.        If TipCtrl.Orientation = NE Then
  160.          Box.Top = 0: Box.Bottom = h - (h * 0.1)
  161.          P(2).x = 0: P(2).y = h
  162.        Else
  163.          Box.Top = h * 0.1: Box.Bottom = h
  164.          P(0).x = (w / 2) - (w * 0.15): P(0).y = (h / 2) - (h * 0.15)
  165.          P(1).x = (w / 2) + (w * 0.15): P(1).y = (h / 2) + (h * 0.15)
  166.          P(2).x = w: P(2).y = 0
  167.        End If
  168.     Case East, West
  169.        P(0).x = (w / 2): P(0).y = (h / 2) + (h * 0.15)
  170.        P(1).x = (w / 2): P(1).y = (h / 2) - (h * 0.15)
  171.        P(2).y = h / 2
  172.        Box.Top = 0: Box.Bottom = h
  173.        If TipCtrl.Orientation = East Then
  174.          Box.Left = w * 0.1: Box.Right = w
  175.          P(2).x = 0
  176.        Else
  177.          Box.Left = 0: Box.Right = w - (w * 0.1)
  178.          P(2).x = w
  179.        End If
  180.     Case NW, SE
  181.        P(0).x = (w / 2) - (w * 0.15): P(0).y = (h / 2) + (h * 0.15)
  182.        P(1).x = (w / 2) + (w * 0.15): P(1).y = (h / 2) - (h * 0.15)
  183.        Box.Left = 0: Box.Right = w
  184.        If TipCtrl.Orientation = NW Then
  185.          Box.Top = 0: Box.Bottom = h - (h * 0.1)
  186.          P(2).x = w: P(2).y = h
  187.        Else
  188.          Box.Top = h * 0.1: Box.Bottom = h
  189.          P(2).x = 0: P(2).y = 0
  190.        End If
  191. End Select
  192. 'Create Region 1: Balloon Body
  193. Select Case TipCtrl.Style
  194.     Case Rectangle
  195.       Reg(0) = CreateRectRgn(Box.Left, Box.Top, Box.Right, Box.Bottom)
  196.     Case Balloon
  197.       Reg(0) = CreateEllipticRgn(Box.Left, Box.Top, Box.Right, Box.Bottom)
  198.     Case Round_Rectangle
  199.       Reg(0) = CreateRoundRectRgn(Box.Left, Box.Top, Box.Right, Box.Bottom, w * 0.2, h * 0.2)
  200. End Select
  201. 'Create Region 2: Tail of the balloon
  202. Reg(1) = CreatePolygonRgn(P(0), 3, 0)
  203. 'Combine regions for balloon shape
  204. CombineRgn Reg(1), Reg(1), Reg(0), RGN_OR
  205. 'Change the Balloonform shape
  206. SetWindowRgn BalloonForm.hwnd, Reg(1), True
  207. 'Adjust de box for fitting the label text
  208. 'in the case of elliptic regions
  209. If TipCtrl.Style = Balloon Then
  210.     BalloonBox.Bottom = Box.Bottom - h * 0.15
  211.     BalloonBox.Left = Box.Left + w * 0.15
  212.     BalloonBox.Right = Box.Right - w * 0.15
  213.     BalloonBox.Top = Box.Top + h * 0.15
  214. Else
  215.     BalloonBox.Bottom = Box.Bottom
  216.     BalloonBox.Left = Box.Left
  217.     BalloonBox.Right = Box.Right
  218.     BalloonBox.Top = Box.Top
  219. End If
  220. End Sub
  221.  
  222. Private Sub DrawLabel()
  223. Dim lngFormat As Long
  224. Dim new_box As RECT
  225. Dim sngArea As Single
  226. Dim oldArea As Single
  227. Dim lngHeight As Long, lngWidth As Long
  228.  
  229. 'Clear control's device context and change display properties
  230. BalloonForm.BackColor = TipCtrl.BackColor
  231. BalloonForm.ForeColor = TipCtrl.ForeColor
  232. Set BalloonForm.Font = TipCtrl.Font
  233. BalloonForm.Cls
  234. 'Set the text format
  235. If TipCtrl.WordBreak = yes Then lngFormat = DT_WORDBREAK
  236. If TipCtrl.TextAlign = Left Then
  237.     lngFormat = lngFormat Or DT_LEFT
  238. ElseIf TipCtrl.TextAlign = Center Then
  239.     lngFormat = lngFormat Or DT_CENTER
  240. Else
  241.     lngFormat = lngFormat Or DT_RIGHT
  242. End If
  243. 'Calculate the rectangle
  244. D